home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1995 December / macformat-031.iso / mac / Shareware City / Comms / Quote Folder / quote.4th next >
Encoding:
Text File  |  1995-09-01  |  8.6 KB  |  249 lines  |  [TEXT/ALFA]
  1. 0 28 +md !
  2. \
  3. \
  4. \  Quote.4th  --  A very simple CGI application in Pocket Forth
  5. \
  6. \
  7. \  RTK, 05-23-95    Last mod: 09-01-95
  8. \
  9. \
  10.  
  11. fvariable c  0.0 c !  \  holds quote count
  12. variable n  0 n !     \  holds number of quotes in database
  13.  
  14. 0 fix  \ set display mode
  15.  
  16. \ Utility words
  17.  
  18. : wsize ( h v -- )  2dup 8 +md 2! 0 +md 2@ 2>r 2>r 256 >r ,$ A91D ;
  19.  
  20. : random ( -- n' ) ( puts a random number from 1 to n on stack )
  21.    0 >r ,$ A861 r> abs n @ 32767 */ 1+ ;
  22.  
  23. : ForeColor ( color -- )  0 2>r ,$ A862 ;
  24. : BackColor ( color -- )  0 2>r ,$ A863 ;
  25.  
  26. : !FONT ( n -- ) >r ,$ A887 ; macro  ( _TextFont ) ( set font )
  27. : !FSIZE ( n -- ) >r ,$ A88A ; macro  ( _TextSize ) ( set size )
  28.  
  29. : <> = 0= ;
  30.  
  31. \ ============== from Datafiles example in PF 6.3 ====================
  32.  
  33. : 00>R ( rstack: -- 0 0 ) ,$ 42A7 ; macro  ( clr.l -[rs] )
  34.  
  35. variable FCB 78 allot  ( our File's Control Block )
  36. : +FCB ( offset -- addr ) fcb + ;  ( offset into fcb )
  37. : 0FCB ( -- ) fcb 80 0 fill ;
  38. : FTRAP ( -- ) fcb >abs  ,$ 205E ;  ( movea.l [ps]+,a0 )
  39.  
  40. : CLOSE ( -- ) ftrap ,$ A001  ftrap ,$ A013 ;  ( close & flush )
  41. : ?DERROR ( -- ) 16 +fcb @ ?dup IF  ( if result not zero )
  42.       ." DiskError" .  close  abort THEN ;  ( report & abort )
  43.  
  44. : EOF ( -- dbytes ) ftrap ,$ A011  30 +fcb @ ;  ( _GetEOF )
  45. : !SIZE ( bytes -- ) 38 +fcb ! ;  ( set bytes-to-read or write )
  46. : !FILE ( -- ) ( set data in fcb to open file from sfreply )
  47.     0fcb  pad 6 + @  22 +fcb  !  ( set vrefnum )
  48.     pad 10 + >abs  18 +fcb  2!  ( set name )
  49.     01 27 +fcb c! ;  ( read only )
  50.  
  51. 2variable $TEXT ,s TEXT  $text 2!
  52. : OPEN ( -- ) ( select and open a file )
  53.     55 75 2>r  ( top left corner )
  54.     00>r   00>r  1 >r  $text a>r  00>r  pad a>r  ( reply at here )
  55.     2 >r  ,$ A9EA  ( _SFGetFile )
  56.     pad @ IF  ( check good field )
  57.       !file  ftrap ,$ A000  ?derror  ( _Open the file )
  58.     ELSE beep quit THEN ;
  59.  
  60. : re-open ( -- ) ( open a file already selected )
  61.     ftrap ,$ A000  ?derror ;  ( _Open )
  62.  
  63. : READ ( dabs.addr -- ) ( allows read outside of dictionary )
  64.     32 +fcb 2!  ( set read buffer pointer )
  65.     ftrap ,$ A002  ?derror ;  ( _Read )
  66.  
  67. : LIST ( -- )
  68.     open  eof  dup 0< IF abs THEN  ( determine file length )
  69.     room 44 -  min  dup !size  ( set bytes to be read )
  70.     pad dup >abs read  close  swap type ;  ( read & type data )
  71.  
  72.  
  73. \ ===================== from AppleEvents file in PF 6.3 =====================
  74.  
  75. 2variable DDATA  4 allot
  76.  
  77. \ Message is a defining word for setting up strings for REPLYing
  78. : MESSAGE[  \ compiling: ( -- ) enclose subsequent ']'ed string
  79.     CREATE  93 word here  c@ 1+ dup 2 mod +  allot
  80.     DOES>  count ;  \ runtime action: ( -- addr count )
  81.  
  82. MESSAGE[ SERROR  Empty stack!]
  83.  
  84. ( get AEDesc handle from an Apple Event )
  85. : ?DESC ( d.key d.type -- desc.handle desc.type -1  or  0 )
  86.     0 >r                                  ( room for error        )
  87.     202 +md 2@ 2>r                        ( the AppleEvent handle )
  88.     2swap 2>r  2>r                        ( keyword and type      )
  89.     here a>r                              ( receiving address     )
  90.     ,$ 303C ,$ 812 ,$ A816 ( AEGetParamDesc: move #$812,d0 _Pack8 )
  91.     r> 0= IF                              ( if there is no error  )
  92.       here 4 + 2@  here 2@  -1            ( get data & leave true )
  93.     ELSE  0 THEN ;                        ( or else leave false   )
  94.  
  95. : -DESC ( addr.where.desc.is.stored -- error ) ( remove desc rec. )
  96.     0 >r  a>r                          ( push room and descriptor )
  97.    ,$ 303C ,$ 0204 ,$ A816 ( AEDisposeDesc: move #$0204,d0 _Pack8 )
  98.     r> ;
  99.  
  100. \ Reply to an Apple Event with a string
  101. : REPLY ( addr count -- )  \ **** USE INSIDE OF A HANDLER ONLY ****
  102.     0 >r                      \ put room for error on rstack
  103.     198 +md 2@ 2>r            \ put the ReplyEvent handle on rstack
  104.     ,s ---- 2>r  ,s TEXT 2>r  \ put keyword and type on rstack
  105.     swap a>r  0 2>r           \ put addr & count on rs from pstack
  106.     ,$ 303C ,$ 0A0F ,$ A816   \ AEPutParamPtr: move #$A0F,d0 _Pack8
  107.     r> drop ;                 \ ignore any error
  108.  
  109. \ ==========================================================================
  110.  
  111. create tString 2048 allot       ( holds the output string )
  112. variable tCount   0 tCount !    ( length of the output string )
  113.  
  114. : >number ( -- n )  \ convert pad into a number, assumes leading zeros
  115.    1000 pad     c@ 48 - *
  116.     100 pad 1+  c@ 48 - * +
  117.      10 pad 2+  c@ 48 - * +
  118.         pad 3 + c@ 48 - + ;
  119.         
  120. : #quotes ( -- n )  \ read the first line and get number of quotes
  121.    5 !SIZE  pad >abs read >number 
  122.    close  re-open  ;
  123.  
  124. message[ s1 <html>]
  125. message[ s2 </html>]
  126.  
  127. : >tString ( c -- )  \ put a character on the end of tString
  128.    tString  tCount @ + c!  tCount @ 1+ tCount ! ;
  129.  
  130. : strcpy  ( addr len -- )  \ copy characters into tString
  131.    >r dup r> + swap do
  132.      r c@ >tString
  133.    loop ;
  134.  
  135. : startString ( -- )  ( load the header text into tString ) 
  136.    0 tCount !  s1 strcpy ; \ copy into tString
  137. : endString ( -- ) s2 strcpy ;  ( load the ending text into tString )
  138.  
  139. : skiplines ( n -- )  \ skips to beginning of n-th quote
  140.    2+ begin dup 0> while           
  141.      1 !size pad >abs read pad c@
  142.      begin 13 <> while
  143.        pad >abs read pad c@
  144.      repeat
  145.      1-
  146.    repeat  ;
  147.  
  148. : getline ( -- )  \ get the current line into tString
  149.    1 !size pad >abs read pad c@
  150.    begin dup 13 <> while
  151.      >tString
  152.      pad >abs read pad c@
  153.    repeat drop ;
  154.  
  155. : reset ( -- )  close re-open ;  \ reset the file
  156.  
  157. : gHead ( -- )  \ read the prefix string
  158.    reset -1 skiplines getline reset ;
  159.  
  160. : gBack ( -- )  \ read the "back" string
  161.    reset 0 skiplines getline ;
  162.  
  163. : getQuote ( -- )    \ pick a random number and output that quote
  164.    reset             \ reset the file
  165.    #quotes n !       \ get the number of quotes in the file
  166.    reset             \ reset again
  167.    startString       \ stuff header info in string
  168.    gHead             \ read prefix string
  169.    random skiplines  \ skip to the right quote
  170.    getline           \ read a line into the string
  171.    gBack             \ read back string
  172.    endString         \ tack on end of string
  173.    reset             \ reset the file
  174. ;
  175.  
  176. 2variable DSIZE  \ this double variable holds the size of a string in dbuff
  177. variable  DBUFF 2046 allot  \ this block is filled with a text string
  178.  
  179. ( get AE data from an Apple Event )
  180. : ?DATA ( d.key -- addr length -1  or  0 )
  181.     0 >r               \ make room on stack for error
  182.     202 +md 2@ 2>r      \ push theAppleEvent address
  183.     2>r  ,s TEXT 2>r     \ push keyword (from pstack) and desired type (TEXT)
  184.     here a>r              \ push an address to hold the actual type
  185.     dbuff a>r              \ push the data receiving address
  186.     2048 s>d 2>r            \ max number of bytes to read
  187.     dsize a>r                \ push a variable to hold the actual size
  188.     ,$ 303C ,$ 0E11 ,$ A816   \ AEGetParamPtr: move #$812,d0 _Pack8
  189.     r> 0= IF                   \ if there is no error
  190.       dbuff  dsize 2@ drop  -1  \ put address, count and true on pstack
  191.     ELSE  0 THEN ;               \ else false 
  192.  
  193. \ Startup screen
  194.  
  195. : update ( -- )  \ update screen showing accesses
  196.    33 BackColor  30 ForeColor  page ( setup colors )
  197.    @pen 3 + !pen  ( move down a bit on the screen )
  198.    0 !FONT 12 !FSIZE  ( Chicago )
  199.    ." Quoter, ver 1.1, RTK, 09/95     "
  200.    1 !FONT 9 !FSIZE   ( Geneva )
  201.    ." This program has been accessed " c f@ 
  202.    fdup 1.0 fcompare 0= >r fdrop fdrop r> IF
  203.      f. ." time."
  204.    ELSE   f. ." times."
  205.    THEN
  206.    4 !FONT  9 !FSIZE  ( Monaco )        ( output IP address )
  207.    cr cr ." Last access from:  " 
  208.    dbuff dsize 2@ drop type
  209.    30000 10 !pen  ( move pen off screen )
  210. ;
  211.  
  212. : startup ( -- )  \ startup word
  213.    512 40 wsize                ( set window size             )
  214.    32 dbuff c!                 ( ' ' as first buff char      )
  215.    1 0 dsize 2!                ( set IP address length       )
  216.    OPEN                        ( get quotation database      )
  217.    update                      ( draw screen                 )
  218.    begin  key drop  again  ;   ( listen to events            )
  219.  
  220.  
  221. \ Install the 'sdoc' handler.
  222.  
  223. ,s sdoc  ,s WWWΩ  ae:  
  224.   ,s addr ?data IF
  225.     drop drop   ( ?data puts the string in dbuff )
  226.   THEN
  227.   c f@ 1.0 f+ c f! Update                ( increment counter )
  228.   ,s ---- ,s TEXT ?desc IF
  229.     ddata 2! ddata 4 + 2!
  230.     ddata -desc 0= IF
  231.      getQuote                    ( lookup the quote )
  232.      tString                     ( address of beginning of the response )
  233.      tCount @                    ( length of the response )
  234.     ELSE  ." Oops!" cr THEN
  235.   ELSE ." Nothing" cr THEN
  236.   reply
  237.   close  re-open   ( reset the database file )
  238. ;ae
  239.  
  240.  
  241. \ setup initialization pointers
  242.  
  243. ' startup  26 +md !    ( startup word )
  244.  
  245. ' update   12 +md !    ( activate window )
  246. ' update   14 +md !    ( update window   )
  247.  
  248. ' bye  18 +md @ @ !    ( first File menu option )
  249.